Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/unix/volume10/comobj.lisp/part12

Text File | 1987-08-23 | 43.9 KB | 1,175 lines

Path: uunet!rs
From: [e-mail] (Rich Salz)
Newsgroups: comp.sources.unix
Subject: v10i086:  Common Objects, Common Loops, Common Lisp, Part12/13
Message-ID: <[e-mail]>
Date: 3 Aug 87 21:19:32 GMT
Organization: UUNET Communications Services, Arlington, VA
Lines: 1164
Approved: [e-mail]

Submitted-by: Roy D'Souza <[e-mail]>
Posting-number: Volume 10, Issue 86
Archive-name: comobj.lisp/Part12

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 12 (of 13)."
# Contents:  methods.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'methods.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'methods.l'\"
else
echo shar: Extracting \"'methods.l'\" \(42046 characters\)
sed "s/^X//" >'methods.l' <<'END_OF_FILE'
X;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted.  Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;;   CommonLoops Coordinator
X;;;   Xerox Artifical Intelligence Systems
X;;;   2400 Hanover St.
X;;;   Palo Alto, CA 94303
X;;; (or send Arpanet mail to [e-mail])
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X
X(in-package 'pcl)
X
X  ;;
X;;;;;; Methods
X  ;;
X
X(ndefstruct (essential-method
X          (:class class)
X          (:conc-name method-))
X  (discriminator nil)
X  (arglist ())
X  (type-specifiers ())
X  (function nil))
X
X(ndefstruct (combinable-method-mixin (:class class)))
X
X(ndefstruct (basic-method
X          (:class class)
X          (:include (essential-method))
X          (:constructor make-method-1)
X          (:conc-name method-))
X  (function nil)
X  (discriminator nil)
X  (type-specifiers ())
X  (arglist ())
X  (options () :allocation :dynamic))
X
X(ndefstruct (method (:class class)
X            (:include (combinable-method-mixin
X                   basic-method))))
X
X
X(ndefstruct (essential-discriminator
X          (:class class)
X          (:conc-name discriminator-))
X  (name nil)
X  (methods ())
X  (discriminating-function ())
X  (classical-method-table nil :allocation :dynamic)
X  (cache ()))
X
X(ndefstruct (method-combination-mixin (:class class)
X                      (:conc-name nil))
X  (method-combination-type :daemon)
X  (method-combination-parameters ())
X  (methods-combine-p ())
X  )
X
X(ndefstruct (basic-discriminator
X          (:class class)
X          (:include (essential-discriminator))
X          (:constructor make-discriminator-1)
X          (:conc-name discriminator-))
X
X  (dispatch-order :default)
X  (inactive-methods () :allocation :dynamic))
X
X(ndefstruct (discriminator (:class class)
X               (:include (method-combination-mixin
X                      basic-discriminator)))
X  )
X
X;;;
X;;; This is really just for bootstrapping, of course this isn't all
X;;; worked out yet.  But this SHOULD really just be for bootstrapping.
X;;;
X(defmeth method-causes-combination-p ((method basic-method))
X  (ignore method)
X  ())
X
X  ;;
X;;;;;;
X  ;;
X
X
X(defun real-expand-defmeth (name&options arglist body)
X  (unless (listp name&options) (setq name&options (list name&options)))
X  (keyword-parse ((discriminator-class 'discriminator)
X                  (method-class 'method))
X                 (cdr name&options)
X    (dolist (x '(:discriminator-class :method-class))
X      (delete x name&options :test #'(lambda (x y)
X                       (and (listp y) (eq (car y) x)))))
X    (let ((discriminator-class-object (class-named discriminator-class t))
X          (method-class-object (class-named method-class t)))
X      (or discriminator-class-object        ;
X          (error
X        "The :DISCRIMINATOR-CLASS option to defmeth was used to specify~
X             that the class~%of the discriminator should be ~S;~%~
X             but there is no class named ~S."
X        discriminator-class
X        discriminator-class))
X      (or method-class-object
X          (error "The :METHOD-CLASS option to defmeth was used to specify~%~
X                  that the class of the method should be ~S;~%~
X                  but there is no class named ~S."
X                 method-class
X                 method-class))
X      (expand-defmeth-internal (class-prototype discriminator-class-object)
X                   (class-prototype method-class-object)
X                   name&options
X                   arglist
X                   body))))
X
X(defvar *method-being-defined*)
X
X(defmeth expand-defmeth-internal ((proto-discriminator basic-discriminator)
X                  (proto-method basic-method)
X                  name&options arglist body)
X  (keyword-parse ((setf () setf-specified-p))
X                 (cdr name&options)
X    (let* ((discriminator-class-name (class-name
X                       (class-of proto-discriminator)))
X           (method-class-name (class-name (class-of proto-method)))
X           (name (car name&options))
X           (merged-arglist (cons (car arglist) (append setf (cdr arglist))))
X           (merged-args (arglist-without-type-specifiers proto-discriminator
X                                                         proto-method
X                                                         merged-arglist))
X           (merged-type-specifiers
X         (defmethod-argument-specializers arglist))
X           discriminator-name
X           method-name
X       (defmethod-uid (gensym))
X       (load-method-1 ())
X       (documentation ())
X       (declarations ()))
X      (if setf-specified-p
X      (setq discriminator-name (make-setf-discriminator-name name)
X        method-name (make-setf-method-name name
X                           (arglist-type-specifiers
X                             proto-discriminator
X                             proto-method
X                             setf)
X                           merged-type-specifiers))
X      (setq discriminator-name name
X        method-name (make-method-name name
X                          merged-type-specifiers)))
X      (multiple-value-setq (documentation declarations body)
X    (extract-declarations body))
X      (setq load-method-1 `(,discriminator-class-name
X                ,method-class-name
X                ,discriminator-name
X                ,merged-type-specifiers
X                ,merged-args
X                ,(cdr name&options)))
X      ;;
X      ;; There are 4 cases:
X      ;;   - evaluated
X      ;;   - compiled to core
X      ;;   - compiled to file
X      ;;   - loading the compiled file
X      ;;
X      ;; When loading a method which has a run-super in it, there is no way
X      ;; to know which of two events will happen first:
X      ;;   1. the load-time-eval form in the run super will be
X      ;;      evaluated first, or
X      ;;   2. the function to install the loaded method (defmethod-uid)
X      ;;      will be evaluated first.
X      ;; consequently, both the special function (defmethod-uid) and the
X      ;; expansion of run-super must check to see if the other has already
X      ;; run and set the value of defmethod-uid to the method involved.
X      ;; This is what causes the boundp checks of defmethod-uid each time
X      ;; before it is set.
X      ;;
X      `(progn
X
X     (eval-when (eval load)
X
X       (defun ,defmethod-uid ()
X         (declare (special ,defmethod-uid))
X         (unless (boundp ',defmethod-uid)
X           (setq ,defmethod-uid (apply #'load-method-1
X                       ',load-method-1)))
X         ,@(and *real-methods-exist-p*
X            `((record-definition
X            ',discriminator-name 'method
X            ',merged-type-specifiers ',(cdr name&options))
X              (setf (symbol-function ',method-name)
X                #'(lambda ,merged-args
X                ,@documentation
X                ,@declarations
X                (declare (method-function-name ,method-name))
X                ,(wrap-method-body
X                   proto-discriminator
X                   (apply 'compile-method-1 load-method-1)
X                   discriminator-name
X                   defmethod-uid
X                   load-method-1
X                   body)
X                ))))
X
X         (setf (method-function ,defmethod-uid)
X           (symbol-function ',method-name))
X
X         (add-method (discriminator-named ',discriminator-name)
X             ,defmethod-uid
X             ()))
X
X       (,defmethod-uid))
X
X     (eval-when (compile load eval)
X
X       ,@(and setf-specified-p
X          `((record-definition
X              ',name 'defsetf ',discriminator-name 'defmeth)
X            (defsetf ,name
X                 ,(arglist-without-type-specifiers
X                proto-discriminator proto-method arglist)
X                 ,(arglist-without-type-specifiers
X                proto-discriminator proto-method setf)
X              (list ',discriminator-name ,@(arglist-args
X                             proto-discriminator
X                             proto-method
X                             merged-args)))))
X
X       ',discriminator-name)))))
X
X(defmethod wrap-method-body ((mex-generic-function discriminator)
X                 (mex-method method)
X                 generic-function-name
X                 method-uid
X                 load-method-1-args
X                 body)
X  (let ((macroexpand-time-information (list mex-generic-function
X                        mex-method
X                        generic-function-name
X                        method-uid
X                        load-method-1-args)))
X    `(macrolet ,(iterate (((name arglist params fn) in *method-body-macros*))
X          (collect `(,name ,arglist
X                   (funcall (function ,fn)
X                    ',macroexpand-time-information
X                    ,@params))))
X       (block ,generic-function-name
X     . ,body))))
X
X(defun macroexpand-time-generic-function (mti) (nth 0 mti))
X
X(defun macroexpand-time-method (mti) (nth 1 mti))
X
X(defun macroexpand-time-generic-function-name (mti) (nth 2 mti))
X
X(defun macroexpand-time-method-uid (mti) (nth 3 mti))
X
X(defun macroexpand-time-load-method-1-args (mti) (nth 4 mti))
X
X
X(defun load-method-1 (discriminator-class-name
X               method-class-name
X               discriminator-name
X               method-type-specifiers
X              method-arglist
X              options)
X  (let* ((discriminator
X       (ensure-selector-specializable
X         (class-prototype (class-named discriminator-class-name))
X         discriminator-name
X         method-arglist))
X     (method
X       (or (find-method discriminator method-type-specifiers options t)
X           (make method-class-name))))
X    (setf (method-arglist method) method-arglist)
X    (setf (method-type-specifiers method)
X      (parse-type-specifiers
X        discriminator method method-type-specifiers))
X    (setf (method-options method) options)
X    method))
X
X(defun compile-method-1 (discriminator-class-name
X             method-class-name
X             discriminator-name
X             method-type-specifiers
X             method-arglist
X             options)
X  (ignore discriminator-name)
X  (let ((method (make method-class-name)))
X    (setf (method-arglist method) method-arglist)
X    (setf (method-type-specifiers method)
X          (parse-type-specifiers
X        (class-prototype (class-named discriminator-class-name))
X        method
X        method-type-specifiers))
X    (setf (method-options method) options)
X    method))
X
X
X
X(defmeth add-named-method ((proto-discriminator essential-discriminator)
X               (proto-method essential-method)
X               discriminator-name
X               arglist
X               type-specs
X               extra
X               function)
X  ;; What about changing the class of the discriminator if there is
X  ;; one.  Whose job is that anyways.  Do we need something kind of
X  ;; like class-for-redefinition?
X  (let* ((discriminator
X       ;; Modulo bootstrapping hair, this is just:
X       ;;   (or (discriminator-named ..)
X       ;;       (make-specializable))
X       (ensure-selector-specializable proto-discriminator
X                      discriminator-name
X                      arglist))
X     (existing (find-method discriminator type-specs extra t))
X     (method (or existing
X             (make (class-of proto-method)))))
X    (when existing (change-class method (class-of proto-method)))
X    (setf (method-arglist method) arglist)
X    (setf (method-function method) function)
X    (setf (method-type-specifiers method) type-specs)
X    (add-method discriminator method extra)))
X
X(defmeth add-method ((discriminator essential-discriminator)
X             (method essential-method)
X             extra)
X  (ignore extra)
X  (let ((type-specs (method-type-specifiers method))
X       ;(options (method-options method))
X       ;(methods (discriminator-methods discriminator))
X    )
X    (setf (method-discriminator method) discriminator)
X;    ;; Put the new method where it belongs, either:
X;    ;;  - The same (EQ) method object is already on discriminator-methods
X;    ;;    of the discriminator so we don't need to do anything to put the
X;    ;;    new methods where it belongs.
X;    ;;  - There is an method on discriminator-methods which is equal to
X;    ;;    the new method (according to METHOD-EQUAL).  In this case, we
X;    ;;    replace the existing method with the new one.
X;    ;;  - We just add the new method to discriminator-methods by pushing
X;    ;;    it onto that list.
X;    (unless (memq method methods)
X;      (do* ((tail (discriminator-methods discriminator) (cdr tail))
X;        (existing-method (car tail) (car tail)))
X;       ((cond ((null existing-method)
X;           (push method (discriminator-methods discriminator)))
X;          ((method-equal existing-method type-specs options)
X;           (remove-method discriminator existing-method)
X;           (return (add-method discriminator method))))
X;
X;        (when (method-causes-combination-p method)             ;NOT part of
X;          (pushnew method (methods-combine-p discriminator)));standard
X;                                         ;protocol.
X;        (dolist (argument-specifier type-specs)
X;          (add-method-on-argument-specifier discriminator
X;                        method
X;                        argument-specifier)))
X;    ()))
X    (pushnew method (discriminator-methods discriminator))
X    (dolist (argument-specifier type-specs)
X      (add-method-on-argument-specifier discriminator
X                    method
X                    argument-specifier)))
X    (discriminator-changed discriminator method t)
X    (update-pretty-arglist discriminator method)    ;NOT part of
X                                ;standard protocol.
X    ())
X
X
X(defmeth remove-named-method (discriminator-name
X                  argument-specifiers
X                  &optional extra)
X  (let ((discriminator ())
X    (method ()))
X    (cond ((null (setq discriminator (discriminator-named
X                       discriminator-name)))
X       (error "There is no discriminator named ~S." discriminator-name))
X      ((null (setq method (find-method discriminator
X                       argument-specifiers
X                       extra
X                       t)))
X       (error "There is no method for the discriminator ~S~%~
X                   which matches the argument-specifiers ~S."
X          discriminator
X          argument-specifiers))
X      (t
X       (remove-method discriminator method)))))
X
X(defmeth remove-method ((discriminator basic-discriminator) method)
X  (setf (method-discriminator method) nil)
X  (setf (discriminator-methods discriminator)
X    (delq method (discriminator-methods discriminator)))
X  (dolist (type-spec (method-type-specifiers method))
X    (remove-method-on-argument-specifier discriminator method type-spec))
X  (discriminator-changed discriminator method nil)
X  discriminator)
X
X
X
X(defmeth add-method-on-argument-specifier
X     ((discriminator essential-discriminator)
X      (method essential-method)
X      argument-specifier)
X  (ignore method)
X  (when (classp argument-specifier)
X    (pushnew method
X         (class-direct-methods argument-specifier))
X    ;; This is a bug.  This needs to be split up into a method on
X    ;; essential class and a method on class or something.
X    (when (methods-combine-p discriminator)
X      (pushnew discriminator
X           (class-discriminators-which-combine-methods
X         argument-specifier)))))
X
X(defmeth remove-method-on-argument-specifier
X     ((discriminator essential-discriminator)
X      (method essential-method)
X      argument-specifier)
X  (ignore method)
X  (when (classp argument-specifier)
X    (setf (class-direct-methods argument-specifier)
X      (delq method
X        (class-direct-methods argument-specifier)))
X    (when (methods-combine-p discriminator)
X      (setf (class-discriminators-which-combine-methods
X          argument-specifier)
X        (delq discriminator
X          (class-discriminators-which-combine-methods
X            argument-specifier))))))
X
X
X(defun make-specializable (function-name &rest options)
X  (when options (setq options (list* ':allow-other-keys t options)))
X  (keyword-bind ((arglist nil arglist-specified-p)
X         (discriminator-class 'discriminator)
X         (dispatch nil dispatch-p))
X        options
X    (cond ((not (null arglist-specified-p)))
X      ((fboundp 'function-arglist)
X       ;; function-arglist exists, get the arglist from it.
X       ;; Note: the funcall of 'function-arglist prevents
X       ;;       compiler warnings at least in some lisps.
X       (setq arglist (funcall 'function-arglist function-name)))
X      ((fboundp function-name)
X       (error
X         "The :arglist argument to make-specializable was not supplied~%~
X              and there is no version of FUNCTION-ARGLIST defined for this~%~
X              port of Portable CommonLoops.~%~
X              You must either define a version of FUNCTION-ARGLIST (which~%~
X              should be easy), and send it off to the Portable CommonLoops~%~
X              people or you should call make-specializable again with the~%~
X              function's arglist as its second argument.")))
X    (setq dispatch
X      (if dispatch-p
X          (iterate ((disp in dispatch))
X        (unless (memq disp arglist)
X          (error "There is a symbol in the :dispatch argument (~S)~%~
X                          which isn't in the arglist."))
X        (collect (position disp arglist)))
X          :default))
X    (let ((discriminator-class-object
X        (if (classp discriminator-class)
X        discriminator-class
X        (class-named discriminator-class t)))
X      (discriminator nil))
X      (if (null discriminator-class-object)
X      (error
X        "The :DISCRIMINATOR-CLASS argument to make-specializable is ~S~%~
X             but there is no class by that name."
X        discriminator-class)
X      (setq discriminator
X        (apply #'make discriminator-class-object
X               :name function-name
X               :dispatch-order dispatch
X               options)))
X;     (setf (function-pretty-arglist function-name) arglist)
X      (if arglist-specified-p
X      (put-slot-always discriminator 'pretty-arglist arglist)
X      (remove-dynamic-slot discriminator 'pretty-arglist))
X      (setf (discriminator-named function-name) discriminator)
X      (when (fboundp function-name)
X    (add-named-method (class-prototype (class-named 'discriminator))
X              (class-prototype (class-named 'method))
X              function-name
X              arglist
X              ()
X              ()
X              (symbol-function function-name)))
X      discriminator)))
X
X
X
X
X
X(defun update-pretty-arglist (discriminator method)
X  (setf (function-pretty-arglist
X      (or (discriminator-name discriminator)
X          (discriminator-discriminating-function discriminator)))
X    (or (get-slot-using-class (class-of discriminator) discriminator
X                  'pretty-arglist t ())
X        (method-arglist method))))
X
X(defmeth discriminator-pretty-arglist ((discriminator basic-discriminator))
X  (or (get-slot-using-class (class-of discriminator) discriminator
X                'pretty-arglist t ())
X      (let ((method (or (discriminator-default-method discriminator)
X            (car (discriminator-methods discriminator)))))
X    (and method (method-arglist method)))))
X
X(defmeth ensure-selector-specializable ((proto-discriminator
X                       essential-discriminator)
X                     selector arglist)
X  (let ((discriminator (discriminator-named selector)))
X    (cond ((not (null discriminator)) discriminator)
X          ((or (not (fboundp selector))
X               (eq *error-when-defining-method-on-existing-function*
X           'bootstrapping))
X           (setf (discriminator-named selector)
X                 (make (class-of proto-discriminator) :name selector)))
X          ((null *error-when-defining-method-on-existing-function*)
X           (make-specializable selector
X                   :arglist arglist
X                   :discriminator-class (class-of
X                              proto-discriminator))
X           (discriminator-named selector))
X          (t
X           (error "Attempt to add a method to the lisp function ~S without~%~
X                   first calling make-specializable.  Before attempting to~
X                   define a method on ~S~% you should evaluate the form:~%~
X                   (~S '~S)"
X                  selector selector 'make-specializable selector)))))
X
X(defmeth find-method (discriminator type-specifiers options &optional parse)
X  (iterate ((method in (discriminator-methods discriminator)))
X    (when (method-equal method
X            (if parse
X                (parse-type-specifiers discriminator
X                           method
X                           type-specifiers)
X                type-specifiers)
X            options)
X      (return method))))
X
X(defmeth method-equal ((method basic-method) argument-specifiers options)
X  (and (equal options (method-options method))
X       (equal argument-specifiers (method-type-specifiers method))))
X
X
X(defmeth discriminator-default-method ((discriminator essential-discriminator))
X  (find-method discriminator () ()))
X
X(defmeth install-discriminating-function ((discriminator
X                        essential-discriminator)
X                      where
X                      function
X                      &optional inhibit-compile-p)
X  (ignore discriminator)
X  (check-type where symbol "a symbol other than NIL")
X  (check-type function function "a funcallable object")
X
X  (when (and (listp function)
X         (eq (car function) 'lambda)
X         (null inhibit-compile-p))
X    (setq function (compile nil function)))
X
X  (if where
X      (setf (symbol-function where) function)
X      (setf (discriminator-discriminating-function discriminator) function)))
X
X
X  ;;
X;;;;;; Discriminator-Based caching.
X  ;;
X;;; Methods are cached in a discriminator-based cache.  The cache is an N-key
X;;; cache based on the number of specialized arguments the discriminator has.
X;;; As yet the size of the cache does not change statically or dynamically.
X;;; Because of this I allow myself the freedom of computing the mask at
X;;; compile time and not even storing it in the discriminator.
X
X(defvar *default-discriminator-cache-size* 8)
X
X(defun make-discriminator-cache (&optional
X                  (size *default-discriminator-cache-size*))
X  (make-memory-block size))
X
X(defun make-discriminator-cache-mask (discriminator-cache
X                      no-of-specialized-args)
X  (make-memory-block-mask (memory-block-size discriminator-cache)
X                          (+ no-of-specialized-args 1)))
X
X(defmeth flush-discriminator-caches ((discriminator essential-discriminator))
X  (let ((cache (discriminator-cache discriminator)))
X    (when cache (clear-memory-block (discriminator-cache discriminator) 0))))
X
X(defmeth initialize-discriminator-cache ((self essential-discriminator)
X                                            no-of-specialized-args)
X  (ignore no-of-specialized-args)
X  (unless (discriminator-cache self)
X    (setf (discriminator-cache self) (make-discriminator-cache))))
X
X(defmacro discriminator-cache-offset (mask &rest classes)
X  `(logand ,mask
X           ,@(iterate ((class in classes))
X           (collect `(object-cache-no ,class ,mask)))))
X
X(defmacro discriminator-cache-entry (cache offset offset-from-offset)
X  `(memory-block-ref ,cache (+ ,offset ,offset-from-offset)))
X
X(defmacro cache-method (cache mask method-function &rest classes)
X  `(let* ((.offset. (discriminator-cache-offset ,mask ,@classes)))
X     ;; Once again, we have to endure a little brain damage because we can't
X     ;; count on having without-interrupts.  I suppose the speed loss isn't
X     ;; too significant since this is only when we get a cache miss.
X     (setf (discriminator-cache-entry ,cache .offset. 0) nil)
X     ,@(iterate ((class in (cdr classes)) (key-no from 1))
X         (collect `(setf (discriminator-cache-entry ,cache .offset. ,key-no)
X             ,class)))
X     (prog1
X       (setf (discriminator-cache-entry ,cache .offset. ,(length classes))
X         ,method-function)
X       (setf (discriminator-cache-entry ,cache .offset. 0) ,(car classes)))))
X
X(defmacro cached-method (var cache mask &rest classes)
X  `(let ((.offset. (discriminator-cache-offset ,mask . ,classes)))
X     (and ,@(iterate ((class in classes) (key-no from 0))
X              (collect
X                `(eq (discriminator-cache-entry ,cache .offset. ,key-no)
X             ,class)))
X          (setq ,var (discriminator-cache-entry ,cache
X                        .offset.
X                        ,(length classes)))
X          t)))
X
X(defmeth make-caching-discriminating-function (discriminator lookup-function
X                                  cache
X                                  mask)
X  (multiple-value-bind (required restp specialized-positions)
X      (compute-discriminating-function-arglist-info discriminator)
X    (funcall (get-templated-function-constructor
X           'caching-discriminating-function
X           required
X           restp
X           specialized-positions
X           lookup-function)
X             discriminator cache mask)))
X
X(defun make-checking-discriminating-function (discriminator method-function
X                                                            type-specs
X                                default-function)
X  (multiple-value-bind (required restp)
X      (compute-discriminating-function-arglist-info discriminator)
X    (let ((check-positions
X        (iterate ((type-spec in type-specs)
X              (pos from 0))
X          (collect (and (neq type-spec 't) pos)))))
X      (apply (get-templated-function-constructor
X           'checking-discriminating-function
X           required
X           restp
X           (if default-function t nil)
X           check-positions)
X             discriminator method-function default-function type-specs))))
X
X
X  ;;
X;;;;;;
X  ;;
X
X(defvar *always-remake-discriminating-function* nil)
X
X(defmeth make-discriminating-function ((discriminator
X                     essential-discriminator))
X  (let ((default (discriminator-default-method discriminator))
X        (methods (discriminator-methods discriminator)))
X    (cond ((null methods)
X       (make-no-methods-discriminating-function discriminator))
X      ((and default (null (cdr methods)))
X           (make-default-method-only-discriminating-function discriminator))
X          ((or (and default (null (cddr methods)))
X           (and (null default) (null (cdr methods))))
X           (make-single-method-only-discriminating-function discriminator))
X          ((every #'(lambda (m)
X                      (classical-type-specifiers-p
X            (method-type-specifiers m)))
X                  methods)
X           (make-classical-methods-only-discriminating-function
X         discriminator))
X          (t
X           (make-multi-method-discriminating-function discriminator)))))
X
X(defmeth make-no-methods-discriminating-function (discriminator)
X  (instaar *always-remake-discriminating-function* nil)
X (discriminator-name discriminator)
X    #'(lambda (&rest ignore)
X    (error "There are no methods on the discriminator ~S,~%~
X                so it is an error to call it."
X           discriminator))))
X
X(defmeth make-default-method-only-discriminating-function
X     ((self essential-discriminator))
X  (install-discriminating-function
X    self
X    (discriminator-name self)
X    (method-function (discriminator-default-method self))))
X
X(defmeth make-single-method-only-discriminating-function
X      ((self essential-discriminator))
X  (let* ((methods (discriminator-methods self))
X     (default (discriminator-default-method self))
X     (method (if (eq (car methods) default)
X             (cadr methods)
X             (car methods)))
X         (method-type-specifiers (method-type-specifiers method))
X         (method-function (method-function method)))
X    (install-discriminating-function
X      self
X      (discriminator-name self)
X      (make-checking-discriminating-function
X    self
X    method-function
X    method-type-specifiers
X    (and default (method-function default))))))
X
X(defmeth make-classical-methods-only-discriminating-function
X      ((self essential-discriminator))
X  (initialize-discriminator-cache self 1)
X  (let ((default-method (discriminator-default-method self))
X    (methods (discriminator-methods self)))
X    (setf (discriminator-classical-method-table self)
X      (cons (and default-method (method-function default-method))
X        (iterate ((method in methods))
X          (unless (eq method default-method)
X            (collect (cons (car (method-type-specifiers method))
X                   (method-function method))))))))
X  (let* ((cache (discriminator-cache self))
X     (mask (make-discriminator-cache-mask cache 1)))
X    (install-discriminating-function
X      self
X      (discriminator-name self)
X      (make-caching-discriminating-function
X    self 'lookup-classical-method cache mask))))
X
X(defun lookup-classical-method (discriminator class)
X  ;; There really should be some sort of more sophisticated protocol going
X  ;; on here.  Compare type-specifiers and all that.
X  (let* ((classical-method-table
X       (get-slot--class discriminator 'classical-method-table)))
X    (or (iterate ((super in (get-slot--class class 'class-precedence-list)))
X          (let ((hit (assq super (cdr classical-method-table))))
X            (when hit (return (cdr hit)))))
X    (car classical-method-table))))
X
X(defmeth make-multi-method-discriminating-function
X      ((self essential-discriminator))
X  (multiple-value-bind (required restp specialized)
X      (compute-discriminating-function-arglist-info self)
X    (ignore required restp)
X    (initialize-discriminator-cache self (length specialized))
X    (let* ((cache (discriminator-cache self))
X       (mask (make-discriminator-cache-mask cache (length specialized))))
X      (install-discriminating-function
X    self
X    (discriminator-name self)
X    (make-caching-discriminating-function
X      self 'lookup-multi-method cache mask)))))
X
X(defvar *lookup-multi-method-internal*
X    (make-array (min 256. call-arguments-limit)))
X
X(defun lookup-multi-method-internal (discriminator classes)
X  (let* ((methods (discriminator-methods discriminator))
X     (cpls *lookup-multi-method-internal*)
X     (order (get-slot--class discriminator 'dispatch-order))
X         (most-specific-method nil)
X         (most-specific-type-specs ())
X     (type-specs ()))
X    ;; Put all the class-precedence-lists in a place where we can save
X    ;; them as we look through all the methods.
X    (without-interrupts
X      (iterate ((class in classes)
X        (i from 0))
X    (setf (svref cpls i) (get-slot--class class 'class-precedence-list)))
X      (dolist (method methods)
X    (setq type-specs (get-slot--class method 'type-specifiers))
X    (when (iterate ((type-spec in  type-specs)
X            (i from 0))
X        (or (eq type-spec 't)
X            (memq type-spec (svref cpls i))
X            (return nil))
X        (finally (return t)))
X      (if (null most-specific-method)
X          (setq most-specific-method method
X            most-specific-type-specs type-specs)
X          (case (compare-type-specifier-lists
X              most-specific-type-specs type-specs nil
X              () classes order)
X        (2 (setq most-specific-method method
X             most-specific-type-specs type-specs))
X        (1))))))
X    (or most-specific-method
X    (discriminator-default-method discriminator))))
X
X(defun lookup-multi-method (discriminator &rest classes)
X  (declare (inline lookup-multi-method-internal))
X  (let ((method (lookup-multi-method-internal discriminator classes)))
X    (and method (method-function method))))
X
X(defun lookup-method (discriminator &rest classes)
X  (declare (inline lookup-multi-method-internal))
X  (lookup-multi-method-internal discriminator classes))
X
X  ;;
X;;;;;; Code for parsing arglists (in the usual case).
X  ;;   (when discriminator is class DISCRIMINATOR and method is class METHOD)
X;;;
X;;; arglist-type-specifiers
X;;; Given an arglist this returns its type-specifiers.  Trailing T's (both
X;;; implicit and explicit) are dropped.  The type specifiers are returned as
X;;; they are found in the arglist, they are not parsed into internal
X;;; type-specs.
X;;;
X(defmeth arglist-type-specifiers ((proto-disc basic-discriminator)
X                  (proto-meth basic-method)
X                  arglist)
X  (let ((arg (car arglist)))
X    (and arglist
X         (not (memq arg '(&optional &rest &key &aux)))  ;Don't allow any
X                                                        ;type-specifiers
X                                                    ;after one of these.
X         (let ((tail (arglist-type-specifiers proto-disc
X                          proto-meth
X                          (cdr arglist)))
X               (type-spec (and (listp arg) (cadr arg))))
X           (or (and tail (cons (or type-spec 't) tail))
X               (and type-spec (cons type-spec ())))))))
X
X;;; arglist-without-type-specifiers
X;;; Given an arglist remove the type specifiers.
X;;;
X(defmeth arglist-without-type-specifiers ((proto-disc basic-discriminator)
X                      (proto-meth basic-method)
X                      arglist)
X  (let ((arg (car arglist)))
X    (and arglist
X         (if (memq arg '(&optional &rest &key &aux))    ;don't allow any
X                                                        ;type-specifiers
X                                                        ;after one of these.
X             arglist
X             (cons (if (listp arg) (car arg) arg)
X                   (arglist-without-type-specifiers proto-disc
X                            proto-meth
X                            (cdr arglist)))))))
X
X(defmeth arglist-args ((discriminator-class basic-discriminator)
X               (method-class basic-method)
X               arglist)
X  (and arglist
X       (cond ((eq (car arglist) '&aux) ())
X             ((memq (car arglist) '(&optional &rest &key))
X              (arglist-args discriminator-class method-class (cdr arglist)))
X             (t
X              ;; This plays on the fact that no type specifiers are allowed
X          ;; on arguments that can have default values.
X              (cons (if (listp (car arglist)) (caar arglist) (car arglist))
X                    (arglist-args discriminator-class
X                  method-class
X                  (cdr arglist)))))))
X
X(defmeth parse-type-specifiers ((proto-discriminator basic-discriminator)
X                (proto-method basic-method)
X                type-specifiers)
X  (iterate ((type-specifier in type-specifiers))
X    (collect (parse-type-specifier proto-discriminator
X                   proto-method
X                   type-specifier))))
X
X(defmeth parse-type-specifier ((proto-discriminator basic-discriminator)
X                                (proto-method basic-method)
X                                type-specifier)
X  (ignore proto-discriminator proto-method)
X  (cond ((eq type-specifier 't) 't)
X        ((symbolp type-specifier)
X         (or (class-named type-specifier nil)
X             (error
X           "~S used as a type-specifier, but is not the name of a class."
X           type-specifier)))
X        ((classp type-specifier) type-specifier)
X        (t (error "~S is not a legal type-specifier." type-specifier))))
X
X(defmeth unparse-type-specifiers ((method essential-method))
X  (iterate ((parsed-type-spec in (method-type-specifiers method)))
X    (collect (unparse-type-specifier method parsed-type-spec))))
X
X(defmeth unparse-type-specifier ((method essential-method) type-spec)
X  (ignore method)
X  (if (classp type-spec)
X      (class-name type-spec)
X      type-spec))
X
X(defun classical-type-specifiers-p (typespecs)
X  (or (null typespecs)
X      (and (classp (car typespecs))
X           (null (cdr typespecs)))))
X
X;;;
X;;; Compute various information about a discriminator's arglist by looking at
X;;; the argument lists of the methods.  The hair for trying not to use &rest
X;;; arguments lives here.
X;;;  The values returned are:
X;;;    number-of-required-arguments
X;;;       the number of required arguments to this discrimator's
X;;;       discriminating function
X;;;    &rest-argument-p
X;;;       whether or not this discriminator's discriminating
X;;;       function takes an &rest argument.
X;;;    specialized-argument-positions
X;;;       a list of the positions of the arguments this discriminator
X;;;       specializes (e.g. for a classical discrimator this is the
X;;;       list: (1)).
X;;;
X;;; As usual, it is legitimate to specialize the -internal function that is
X;;; why I put it there, since I certainly could have written this more
X;;; efficiently if I didn't want to provide that extensibility.
X;;;
X(defmeth compute-discriminating-function-arglist-info
X     ((discriminator essential-discriminator)
X      &optional (methods () methods-p))
X  (declare (values number-of-required-arguments
X                   &rest-argument-p
X                   specialized-argument-postions))
X  (unless methods-p
X    (setq methods (discriminator-methods discriminator)))
X  (let ((number-required nil)
X        (restp nil)
X        (specialized-positions ()))
X    (iterate ((method in methods))
X      (multiple-value-setq (number-required restp specialized-positions)
X        (compute-discriminating-function-arglist-info-internal
X      discriminator method number-required restp specialized-positions)))
X    (values number-required restp (sort specialized-positions #'<))))
X
X(defmeth compute-discriminating-function-arglist-info-internal
X     ((discriminator essential-discriminator)
X      (method essential-method)
X      number-of-requireds restp specialized-argument-positions)
X  (ignore discriminator)
X  (let ((requireds 0))
X    ;; Go through this methods arguments seeing how many are required,
X    ;; and whether there is an &rest argument.
X    (iterate ((arg in (method-arglist method)))
X      (cond ((eq arg '&aux) (return))
X            ((memq arg '(&optional &rest &key))
X             (return (setq restp t)))
X        ((memq arg lambda-list-keywords))
X            (t (incf requireds))))
X    ;; Now go through this method's type specifiers to see which
X    ;; argument positions are type specified.  Treat T specially
X    ;; in the usual sort of way.  For efficiency don't bother to
X    ;; keep specialized-argument-positions sorted, rather depend
X    ;; on our caller to do that.
X    (iterate ((type-spec in (method-type-specifiers method))
X              (pos from 0))
X      (unless (eq type-spec 't)
X    (pushnew pos specialized-argument-positions)))
X    ;; Finally merge the values for this method into the values
X    ;; for the exisiting methods and return them.  Note that if
X    ;; num-of-requireds is NIL it means this is the first method
X    ;; and we depend on that.
X    (values (min (or number-of-requireds requireds) requireds)
X            (or restp
X        (and number-of-requireds (/= number-of-requireds requireds)))
X            specialized-argument-positions)))
X
X(defun make-discriminating-function-arglist (number-required-arguments restp)
X  (iterate ((i from 0 below number-required-arguments))
X    (collect (intern (format nil "Discriminating Function Arg ~D" i)))
X    (finally (when restp
X               (collect '&rest)
X               (collect (intern "Discriminating Function &rest Arg"))))))
X
X(defmeth compare-methods (discriminator method-1 method-2)
X  (ignore discriminator)
X  (let ((compare ()))
X    (iterate ((ts-1 in (method-type-specifiers method-1))
X          (ts-2 in (method-type-specifiers method-2)))
X      (cond ((eq ts-1 ts-2) (setq compare '=))
X        ((eq ts-1 't)   (setq compare method-2))
X        ((eq ts-2 't)   (setq compare method-1))
X        ((memq ts-1 (class-class-precedence-list ts-2))
X         (setq compare method-2))
X        ((memq ts-2 (class-class-precedence-list ts-1))
X         (setq compare method-1))
X        (t (return nil)))
X      (finally (return compare)))))
X
X  ;;
X;;;;;; Comparing type-specifiers, statically or wrt an object.
X  ;;
X;;; compare-type-specifier-lists compares two lists of type specifiers
X;;; compare-type-specifiers compare two type specifiers
X;;; If static-p it t the comparison is done statically, otherwise it is
X;;; done with respect to object(s).  The value returned is:
X;;;    1    if type-spec-1 is more specific
X;;;    2    if type-spec-2 is more specific
X;;;    =    if they are equal
X;;;    NIL  if they cannot be disambiguated
X;;;
X(defun compare-type-specifier-lists (type-spec-list-1
X                     type-spec-list-2
X                     staticp
X                     args
X                     classes
X                     order)
X  (when (or type-spec-list-1 type-spec-list-2)
X    (ecase (compare-type-specifiers (or (car type-spec-list-1) t)
X                                    (or (car type-spec-list-2) t)
X                                    staticp
X                                    (car args)
X                                    (car classes))
X      (1 '1)
X      (2 '2)
X      (= (if (eq order :default)
X         (compare-type-specifier-lists (cdr type-spec-list-1)
X                       (cdr type-spec-list-2)
X                       staticp
X                       (cdr args)
X                       (cdr classes)
X                       order)
X         (compare-type-specifier-lists (nth (car order) type-spec-list-1)
X                       (nth (car order) type-spec-list-2)
X                       staticp
X                       (cdr args)
X                       (cdr classes)
X                       (cdr order))))
X
X      (nil
X        (unless staticp
X          (error "The type specifiers ~S and ~S can not be disambiguated~
X                  with respect to the argument: ~S"
X                 (or (car type-spec-list-1) t)
X                 (or (car type-spec-list-2) t)
X                 (car args)
X                 (car classes)))))))
X
X(defun compare-type-specifiers (type-spec-1 type-spec-2 staticp arg class)
X  (cond ((equal type-spec-1 type-spec-2) '=)
X        ((eq type-spec-2 t) '1)
X        ((eq type-spec-1 t) '2)
X        ((and (classp type-spec-1) (classp type-spec-2))
X;        (if staticp
X;            (if (common-subs type-spec-1 type-spec-2)
X;                nil
X;                (let ((supers (common-supers type-spec-1 type-spec-2)))
X;                  (cond ((cdr supers) nil)
X;                        ((eq (car supers) type-spec-1) '2)
X;                        ((eq (car supers) type-spec-2) '1)
X;                        (t 'disjoint))))
X             (iterate ((super in (class-class-precedence-list (or class (class-of arg)))))
X               (cond ((eq super type-spec-1)
X                      (return '1))
X                     ((eq super type-spec-2)
X                      (return '2)))))
X;)
X        (t
X         (compare-complex-type-specifiers type-spec-1 type-spec-2 staticp arg class))))
X
X(defun compare-complex-type-specifiers (type-spec-1 type-spec-2 static-p arg class)
X  (ignore type-spec-1 type-spec-2 static-p arg class)
X  (error "Complex type specifiers are not yet supported."))
X
X(defmeth no-matching-method (discriminator)
X  (let ((class-of-discriminator (class-of discriminator)))
X    (if (eq (class-of class-of-discriminator) (class-named 'class))
X        ;; The meta-class of the discriminator is class, we can get at
X        ;; it's name slot without doing any method lookup.
X        (let ((name (get-slot--class discriminator 'name)))
X          (if (and name (symbolp name))
X              (error "No matching method for: ~S." name)
X              (error "No matching method for the anonymous discriminator: ~S."
X                     discriminator)))
X        (error "No matching method for the discriminator: ~S." discriminator))))
X  ;;
X;;;;;; Optimizing GET-SLOT
X  ;;
X
X(defmeth method-argument-class ((method basic-method) argument)
X  (let* ((arglist (method-arglist method))
X         (position (position argument arglist)))
X    (and position (nth position (method-type-specifiers method)))))
X
X
X(defmeth optimize-get-slot ((class basic-class)
X                form)
X  (declare (ignore class))
X  (cons 'get-slot--class (cdr form)))
X
X(defmeth optimize-setf-of-get-slot ((class basic-class)
X                    form)
X  (declare (ignore class))
X  (cons 'put-slot--class (cdr form)))
X
END_OF_FILE
if test 42046 -ne `wc -c <'methods.l'`; then
    echo shar: \"'methods.l'\" unpacked with wrong size!
fi
# end of 'methods.l'
fi
echo shar: End of archive 12 \(of 13\).
cp /dev/null ark12isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 13 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0
--

Rich $alz            "Anger is an energy"
Cronus Project, BBN Labs    [e-mail]
Moderator, comp.sources.unix    [e-mail]